home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / METHODS.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  8.8 KB  |  253 lines
  1. ;* METHODS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*    Scoops: Addition Redefinition and Deletion of Methods        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; is class1 before class2 in class ?
  23. ; class1  is not equal to class2
  24.  
  25. (define %before
  26.   (lambda (class1 class2 class)
  27.     (or (eq? class1 class)
  28.         (memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
  29.  
  30. ;
  31.  
  32. (macro define-method
  33.   (lambda (e)
  34.     (let ((class-name (caadr e))
  35.           (method-name (cadr (cadr e)))
  36.           (formal-list (caddr e))
  37.           (body (cdddr e)))
  38.       `(%SC-CLASS-ADD-METHOD
  39.         ',class-name
  40.         ',method-name
  41.         ',class-name
  42.         ',class-name
  43.         ,(%sc-expand
  44.           `(LAMBDA ,formal-list
  45.              (LET ((SELF (FLUID SELF)))
  46.                ,@body)))
  47.         (LAMBDA (ENV VAL)
  48.           (SET! (ACCESS ,method-name ENV) VAL))))))
  49.  
  50.  
  51. ;
  52.  
  53. (define %sc-class-add-method
  54.   (lambda (class-name method-name method-class mixin-class method assigner)
  55.     (let ((class (%sc-name->class class-name)))
  56.          (apply-if (assq method-name (%sc-method-values class))
  57.             (lambda (entry)
  58.               (set-cdr! entry method))
  59.             (%sc-set-method-values class
  60.                (cons (cons method-name method) (%sc-method-values class)))))
  61.     (%compiled-add-method class-name method-name method-class mixin-class
  62.                          method assigner)))
  63.  
  64.  
  65. ;
  66.  
  67. (define %inform-subclasses
  68.   (lambda (class-name method-name method-class mixin-class method assigner)
  69.     ((rec loop
  70.        (lambda (class-name method-name method-class mixin-class
  71.                                        method assigner subclass)
  72.          (if subclass
  73.              (begin
  74.                 (%compiled-add-method
  75.                   (car subclass) method-name method-class class-name
  76.                   method assigner)
  77.                 (loop class-name method-name method-class mixin-class
  78.                       method assigner
  79.                       (cdr subclass))))))
  80.      class-name method-name method-class mixin-class method assigner
  81.      (%sc-subclasses (%sc-name->class class-name)))))
  82.  
  83.  
  84. ;
  85.  
  86. (define %compiled-add-method
  87.   (lambda (class-name method-name method-class mixin-class method assigner)
  88.     (letrec
  89.       ((class (%sc-name->class class-name))
  90.  
  91.        (insert-entry
  92.          (lambda (previous current)
  93.            (cond ((null? current)
  94.                   (set-cdr! previous
  95.                      (cons (cons method-class mixin-class) '())))
  96.                  ((eq? mixin-class (cdar current))
  97.                   (set-car! (car current) method-class))
  98.                  ((%before mixin-class (cdar current)
  99.                            class-name)
  100.                   (set-cdr! previous
  101.                      (cons (cons method-class mixin-class) current)))
  102.                  (else '()))))
  103.  
  104.  
  105.        (loop-insert
  106.          (lambda (previous current)
  107.            (if (not (insert-entry previous current))
  108.                (loop-insert (current) (cdr current)))))
  109.  
  110.        (insert
  111.          (lambda (entry)
  112.            (if (insert-entry entry (cdr entry))  ;;; insert at head
  113.                (add-to-environment)
  114.                (loop-insert (cdr entry) (cddr entry)))))
  115.  
  116.        (add-to-environment
  117.          (lambda ()
  118.            (if (%sc-class-compiled class)
  119.                (assigner (%sc-method-env class) method))
  120.            (if (%sc-subclasses class)
  121.                (%inform-subclasses class-name method-name method-class
  122.                                   mixin-class method assigner))))
  123.  
  124.        (add-entry
  125.          (lambda ()
  126.            (%sc-set-method-structure class
  127.              (cons (list method-name (cons method-class mixin-class))
  128.                    (%sc-method-structure class)))
  129.            (add-to-environment)))
  130.       )
  131.  
  132.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  133.         (if method-entry
  134.             (insert method-entry)
  135.             (add-entry))
  136.         method-name))))
  137.  
  138. ;
  139.  
  140. (macro delete-method
  141.   (lambda (e)
  142.     (let ((class-name (caadr e))
  143.           (method-name (cadr (cadr e))))
  144.       `(%SC-CLASS-DEL-METHOD
  145.         ',class-name
  146.         ',method-name
  147.         ',class-name
  148.         ',class-name
  149.         (LAMBDA (ENV VAL)
  150.           (SET! (ACCESS ,method-name ENV) VAL))
  151.         #F))))
  152.  
  153. ;
  154.  
  155. (define %deleted-method
  156.   (lambda (name)
  157.     (lambda args
  158.       (error-handler name 3 #T))))
  159.  
  160.  
  161. ;
  162.  
  163. (define %sc-class-del-method
  164.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  165.     (let ((class (%sc-name->class class-name)))
  166.       (apply-if (assq method-name (%sc-method-values class))
  167.         (lambda (entry)
  168.           (%sc-set-method-values class
  169.                (delq! entry (%sc-method-values class)))
  170.           (%compiled-del-method class-name method-name method-class mixin-class
  171.                                assigner del-value))
  172.  
  173.         (error-handler method-name 4 #T)))))
  174.  
  175.  
  176. ;
  177.  
  178. (define %inform-del-subclasses
  179.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  180.     ((rec loop
  181.        (lambda (class-name method-name method-class mixin-class assigner
  182.                 del-value subclass)
  183.          (if subclass
  184.              (begin
  185.                 (%compiled-del-method (car subclass) method-name
  186.                           method-class class-name assigner del-value)
  187.                 (loop class-name method-name method-class mixin-class assigner
  188.                       del-value (cdr subclass))))))
  189.      class-name method-name method-class mixin-class assigner del-value
  190.      (%sc-subclasses (%sc-name->class class-name)))))
  191.  
  192.  
  193. ;
  194.  
  195. (define %compiled-del-method
  196.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  197.     (let ((class (%sc-name->class class-name)))
  198.       (letrec
  199.         ((delete-entry
  200.            (lambda (previous current)
  201.              (cond ((eq? mixin-class (cdar current))
  202.                     (set-cdr! previous (cdr current)) #T)
  203.                    (else #F))))
  204.  
  205.          (loop-delete
  206.            (lambda (previous current)
  207.              (cond ((or (null? current)
  208.                         (%before mixin-class (cdar previous)
  209.                                  class-name))
  210.                     (error-handler method-name 4 #T))
  211.                    ((delete-entry previous current) #T)
  212.                    (else (loop-delete current (cdr current))))))
  213.  
  214.          (delete
  215.            (lambda (entry)
  216.              (if (delete-entry entry (cdr entry))  ;;; delete at head
  217.                  (modify-environment entry)
  218.                  (loop-delete (cdr entry) (cddr entry)))))
  219.  
  220.        (modify-environment
  221.          (lambda (entry)
  222.            (cond ((null? (cdr entry))
  223.                   (%sc-set-method-structure class
  224.                     (delq! (assq method-name (%sc-method-structure class))
  225.                            (%sc-method-structure class)))
  226.                   (if (%sc-class-compiled class)
  227.                       (assigner (%sc-method-env class)
  228.                                 (or del-value
  229.                                     (set! del-value
  230.                                           (%deleted-method method-name)))))
  231.                   (if (%sc-subclasses class)
  232.                       (%inform-del-subclasses class-name method-name
  233.                                method-class mixin-class assigner del-value)))
  234.                  (else
  235.                   (let ((meth-value
  236.                          (%sc-get-meth-value method-name
  237.                                              (%sc-name->class (caadr entry)))))
  238.                     (if (%sc-class-compiled class)
  239.                         (assigner (%sc-method-env class) meth-value))
  240.                     (if (%sc-subclasses class)
  241.                         (%inform-subclasses class-name
  242.                                             method-name
  243.                                             method-class
  244.                                             mixin-class
  245.                                             meth-value assigner)))))))
  246.       )
  247.  
  248.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  249.         (if method-entry
  250.             (delete method-entry)
  251.             (error-handler method-name 4 #T))
  252.         method-name)))))
  253.